home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / contrib / zelk / scm / basics < prev    next >
Encoding:
Text File  |  1992-11-13  |  6.3 KB  |  223 lines
  1. ;;; -*-Scheme-*-
  2. ;;; basics--split from toplevel for zelk, to provide error handling for
  3. ;;; elk shells.
  4. ;;; If elk is invoked without any -l files to load, it always loads
  5. ;;; the file toplevel, which in turn (requires) this file.  
  6. ;;; #! Elk invokes elk with the name of the script as the first arg.
  7. ;;; In this case, this file loads the first arg and resets the
  8. ;;; top level handler locally here, so that the (require 'basics) in
  9. ;;; top level never returns - the new local top level exits instead.
  10. ;;; Load -l does not produce any commandline arguments
  11. ;;; (Not sure if -l still works with this scheme.)
  12. ;;; modified zilla
  13. ;;; 17oct    update to 2.0
  14. ;;; 3mar    update to 1.5b
  15. ;;; 18feb    error handler prints hostname
  16. ;;; 13dec    load anything mentioned on commandline.  allows #! shells
  17. ;;; 4sep    fix "1+" bug (error-handler redefined w/o setting context)
  18. ;;; 28aug    load .elkrc into top-level-environment
  19.  
  20. ;(display "loading basics")(newline)
  21. (provide 'basics) ;&zelk
  22.  
  23. (autoload 'pp 'pp)
  24. (autoload 'apropos 'apropos)
  25. (autoload 'flame 'flame)
  26. (autoload 'sort 'qsort)
  27. (autoload 'define-structure 'struct)
  28. (autoload 'describe 'describe)
  29. (autoload 'backtrace 'debug)
  30. (autoload 'inspect 'debug)
  31.  
  32. ;; &zelk synonyms for naming consistency
  33. (define os-chdir chdir)
  34. (define os-read-directory read-directory)
  35. (define os-file-status file-status)
  36. (define os-file-exists? file-exists?)
  37. (define os-bsh system)
  38. (define os-csh csh)
  39.  
  40. ;;&zelk
  41. ;;**************** define top-level reploop, but top-level
  42. ;;**************** is only called in the file toplevel.
  43. ;;**************** define it here so that it can be used as an error reploop
  44.  
  45. (define ?)
  46. (define ??)
  47. (define ???)
  48. (define !)
  49. (define !!)
  50. (define !!!)
  51. (define &)
  52.  
  53. (define (rep-loop env)
  54.   (define input)
  55.   (define value)
  56.   (let loop ()
  57.     (set! ??? ??)
  58.     (set! ?? ?)
  59.     (set! ? &)
  60.     ;;; X Windows hack
  61.     (if (and (bound? 'display-flush-output) (bound? 'dpy) (display? dpy))
  62.     (display-flush-output dpy))
  63.     (if (> rep-level 0)
  64.     (display rep-level))
  65.     (display "> ")
  66.     (set! input (read))
  67.     (set! & input)
  68.     (if (not (eof-object? input))
  69.     (begin
  70.       (set! value (eval input env))
  71.       (set! !!! !!)
  72.       (set! !! !)
  73.       (set! ! value)
  74.       (write value)
  75.       (newline)
  76.       (loop)
  77.     );begin
  78.     );if. returns () on eof
  79.   );let
  80. );rep-loop
  81.  
  82. (define rep-frames)
  83. (define rep-level)
  84.  
  85. (define-macro (push-frame control-point)
  86.   `(begin
  87.      (set! rep-frames (cons ,control-point rep-frames))
  88.      (set! rep-level (1+ rep-level))))
  89.  
  90. (define-macro (pop-frame)
  91.   '(begin
  92.      (set! rep-frames (cdr rep-frames))
  93.      (set! rep-level (1- rep-level))))
  94.  
  95. (define top-level-environment (the-environment))
  96.  
  97. (define (top-level)
  98.   (let loop ()
  99.     ;(format #t "toplevel ")
  100.     (if (call-with-current-continuation
  101.      (lambda (control-point)
  102.        (set! rep-frames (list control-point))
  103.        (set! top-level-control-point control-point)
  104.        (set! rep-level 0)
  105.        (rep-loop top-level-environment)
  106.        #f))
  107.     ; if lambda returns normally, #f is returned and loop is not called.
  108.     ; lambda will only return normally on eof.
  109.     ; control-point is called with #t by error/interrupt handlers,
  110.     ; in which case we start a new reploop.
  111.     (loop)
  112.     );if
  113.   );let
  114. );top-level
  115.  
  116. (define (the-top-level)
  117.   (top-level)
  118.   (newline)
  119.   (exit))
  120.  
  121.  
  122. (define simple-interrupt-handler
  123.   (lambda ()
  124.     (format #t "~%\7Interrupt!~%")
  125.     (let ((next-frame (car rep-frames)))
  126.       (next-frame #t))))        ;throw to most recent continuation
  127.  
  128. ;; backtrace and inspect on ^C.
  129. (define debug-interrupt-handler
  130.   (lambda ()
  131.     (format #t "~%\7Interrupt!~%")
  132.     (backtrace)                ;&zilla
  133.     (inspect)
  134.     (newline)
  135.     (pop-frame)
  136.     (let ((next-frame (car rep-frames)))
  137.       (next-frame #t))
  138.   );lambda
  139. );define
  140.  
  141.  
  142. ;; shell file can set debug-interrupt-handler if desired.
  143. ; problem if we are interrupted between now and the binding of
  144. ; rep-* below.  could fix this by setting interrupt-handler immediately
  145. ; after setting up rep-*.
  146. (set! interrupt-handler simple-interrupt-handler)
  147. ;(set! interrupt-handler debug-interrupt-handler)
  148.  
  149. (define (error-print error-msg)
  150.   (format #t "~s: " (car error-msg))
  151.   (apply format `(#t ,@(cdr error-msg)))
  152.   (newline))
  153.  
  154. ; if an error occurs before rep-* are assigned below,
  155. ; push-frame fails because rep-level is unbound
  156. (set! error-handler
  157.   (lambda error-msg
  158.     (format #t "ERROR........~a ~a~%" (os-hostname) (command-line-args))
  159.     (error-print error-msg)
  160.     (backtrace)                ;&zilla
  161.     (let loop ()
  162.       (if (call-with-current-continuation
  163.        (lambda (control-point)
  164.          (push-frame control-point)
  165.          (rep-loop (the-environment))
  166.          #f))
  167.       ;; lambda will return #f on eof, in which case we fall out
  168.       ;; below the let, do pop-frame and invoke the next frame with #t.
  169.       ;; If the next frame is also an error, we are back here and
  170.       ;; go into this begin, which will in turn probably be exited with ^D
  171.       ;; The last frame will always be a toplevel frame.
  172.       (begin            ;then
  173.         (pop-frame)
  174.         ;(format #t "errloop begin~%")
  175.         (loop)
  176.       );begin
  177.       );if
  178.     );let
  179.     ;(format #t "error-handler past loop~%")
  180.     (newline)
  181.     (pop-frame)
  182.     (let ((next-frame (car rep-frames)))
  183.       (next-frame #t))
  184.   );lambda
  185. );set
  186.  
  187. ;; &zelk
  188. ;; set up a context to load .elkrc.  load *after* provide basics.
  189. ;; If an error occurs, we want to escape past the loading to
  190. ;; avoid an infinite loop.
  191. (call-with-current-continuation
  192.   (lambda (control-point)
  193.     (set! rep-frames (list control-point))
  194.     (set! top-level-control-point control-point)
  195.     (set! rep-level 0)
  196.     (let ((ini (tilde-expand "~/.elkrc")))
  197.       (if (file-exists? ini) (load ini top-level-environment)))
  198.     #f))
  199.  
  200. ;; if (command-line-args) we decide that we are running a #! shell script:
  201. ;; load THE FIRST file mentioned on the commandline:
  202. ;;  "elk -l file" does not result in any commandline arguments
  203. ;;  "junk.esh: #! /ac/res/cnc/zilla/Elk" results in Elk being run
  204. ;;   with junk.esh as its first argument.  
  205. ;; Although toplevel loaded basics (this file), we set up a
  206. ;; continuation here which will exit if the shell load ever returns,
  207. ;; so basics will never return to toplevel.
  208. ;;
  209. (if (command-line-args)
  210.     (begin
  211.      (call-with-current-continuation
  212.       (lambda (control-point)
  213.     (set! rep-frames (list control-point))
  214.     (set! top-level-control-point control-point)
  215.     (set! rep-level 0)
  216.     (let ((a (tilde-expand (car (command-line-args)))))
  217.       (format #t "! loading ~a~%" a)
  218.       (load a top-level-environment)))
  219.      );call/cc
  220.      (exit 0)
  221.     );begin
  222. )
  223.